home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / ktencode / ktencode.frm < prev    next >
Text File  |  1995-05-08  |  9KB  |  333 lines
  1. VERSION 2.00
  2. Begin Form Form1 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "KTEncode"
  5.    ClientHeight    =   6615
  6.    ClientLeft      =   375
  7.    ClientTop       =   495
  8.    ClientWidth     =   8655
  9.    Height          =   7020
  10.    Left            =   315
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   6615
  13.    ScaleWidth      =   8655
  14.    Top             =   150
  15.    Width           =   8775
  16.    Begin CommandButton Command2 
  17.       Caption         =   "Decode"
  18.       Height          =   495
  19.       Left            =   5880
  20.       TabIndex        =   4
  21.       Top             =   120
  22.       Width           =   2415
  23.    End
  24.    Begin TextBox Text2 
  25.       Height          =   375
  26.       Left            =   360
  27.       TabIndex        =   2
  28.       Top             =   360
  29.       Width           =   2655
  30.    End
  31.    Begin CommandButton Command1 
  32.       Caption         =   "Encode"
  33.       Height          =   495
  34.       Left            =   3240
  35.       TabIndex        =   1
  36.       Top             =   120
  37.       Width           =   2415
  38.    End
  39.    Begin TextBox Text1 
  40.       FontBold        =   0   'False
  41.       FontItalic      =   0   'False
  42.       FontName        =   "Terminal"
  43.       FontSize        =   9
  44.       FontStrikethru  =   0   'False
  45.       FontUnderline   =   0   'False
  46.       Height          =   5535
  47.       Left            =   240
  48.       MultiLine       =   -1  'True
  49.       TabIndex        =   0
  50.       Top             =   840
  51.       Width           =   8175
  52.    End
  53.    Begin Label Label1 
  54.       BackColor       =   &H00C0C0C0&
  55.       Caption         =   "Password"
  56.       Height          =   255
  57.       Left            =   360
  58.       TabIndex        =   3
  59.       Top             =   120
  60.       Width           =   2295
  61.    End
  62. End
  63.  
  64. Sub Command1_Click ()
  65.  
  66.   'Encode Text1
  67.   text1.Text = KTEncrypt(Text2.Text, text1.Text, 0, Errors$)
  68.  
  69.   'Errors??
  70.   If Errors$ <> "" Then MsgBox Errors$, 16, "KTEncrypt Error"
  71.  
  72.  
  73. End Sub
  74.  
  75. Sub Command2_Click ()
  76.   
  77.   'Decode text1
  78.   text1.Text = KTEncrypt(Text2.Text, text1.Text, 1, Errors$)
  79.   
  80.   'Errors??
  81.   If Errors$ <> "" Then MsgBox Errors$, 16, "KTEncrypt Error"
  82.  
  83.  
  84. End Sub
  85.  
  86. Sub Form_Load ()
  87.   
  88.   'Line feed
  89.   LF$ = Chr$(13) + Chr$(10)
  90.  
  91.   'A message
  92.   msg$ = "Hello," + LF$ + LF$ + LF$
  93.   msg$ = msg$ + "This is a demonstration program of the KTEncrpyt Function."
  94.   msg$ = msg$ + "  Any text in this text box will be encrypted based on a"
  95.   msg$ = msg$ + " password entered above.  Type in a password of at least"
  96.   msg$ = msg$ + " one character then press Encode.  You will see a transformed"
  97.   msg$ = msg$ + " text that is impossible to decifer.  Keeping the password"
  98.   msg$ = msg$ + " the same,  press the decode button and see the file restored."
  99.   msg$ = msg$ + " Try it again but before Decoding change the password and see"
  100.   msg$ = msg$ + " what happens.  Either you get a 'INVALID PASSWORD' error or"
  101.   msg$ = msg$ + " you just get a bunch of useless text.  Feel free to use this"
  102.   msg$ = msg$ + " Function as you please.  The only restriction is if you pass"
  103.   msg$ = msg$ + " it on please distribute the orignal unmodified files in a ZIP"
  104.   msg$ = msg$ + " format.  If you find it usefull or have questions or comments"
  105.   msg$ = msg$ + " send them to:" + LF$ + LF$ + LF$
  106.   msg$ = msg$ + "     K & T " + LF$
  107.   msg$ = msg$ + "     Karl D Albrecht" + LF$
  108.   msg$ = msg$ + "     P.O. Box 478" + LF$
  109.   msg$ = msg$ + "     San Lorenzo, CA 94580-0478" + LF$ + LF$ + LF$
  110.   msg$ = msg$ + "or Send E-Mail to America Online -> KARL25  (KARL25@AOL.COM)" + LF$ + LF$ + LF$
  111.   msg$ = msg$ + "Please read the READTHIS.TXT file for programming information "
  112.   
  113.   text1.Text = msg$
  114.  
  115. End Sub
  116.  
  117. 'Programmed by Karl Albrecht (KARL25@AOL.COM)
  118. Function KTEncrypt (ByVal PASSWORD$, ByVal strng$, Flag%, Errors$)
  119.   
  120.   'Dimension the Adjust array
  121.   ReDim Adjust(4)
  122.   
  123.   'Set error capture routine
  124.   On Local Error GoTo ErrorHandler
  125.  
  126.   'Preserve original string
  127.   original$ = strng$
  128.  
  129.   
  130.   
  131.   'Check for errors (Errorcodes are custom)
  132.   'Is there Password??
  133.   If Len(PASSWORD$) = 0 Then Error 31100
  134.   
  135.   'Is there a strng$ to work with?
  136.   If Len(strng$) = 0 Then Error 31110
  137.  
  138.   'Check to see if it is an encoded file
  139.   If Right$(strng$, 5) = String$(5, 255) Then
  140.     'if encoding warn!
  141.     If Flag% = 0 Then Error 31120
  142.   Else
  143.     'If decoding warn
  144.     If Flag% <> 0 Then Error 31130
  145.   End If
  146.   
  147.  
  148.   
  149.   'Create a four part encryption code based on password
  150.   'First Adjust code based on length of password
  151.   Adjust(1) = Len(PASSWORD$)
  152.   
  153.   'If first character ascii code even make adjust negative
  154.   If Asc(Left$(PASSWORD$, 1)) / 2 = Int(Asc(Left$(PASSWORD$, 1)) / 2) Then
  155.     Adjust(1) = Adjust(1) * -1
  156.   End If
  157.  
  158.   'Second Adjust code based on first and last character ascii codes
  159.   Adjust(2) = Asc(Left$(PASSWORD$, 1)) - Asc(Right$(PASSWORD$, 1))
  160.  
  161.   'Third code based on average of all ascii codes
  162.   TotalAscii = 0
  163.   For Looper = 1 To Len(PASSWORD$)
  164.     TotalAscii = TotalAscii + Asc(Mid$(PASSWORD$, Looper, 1))
  165.   Next Looper
  166.   Adjust(3) = Int(TotalAscii / Len(PASSWORD$) / 3)
  167.  
  168.   'Fourth code based on previous three
  169.   Adjust(4) = Adjust(1) + Adjust(2) + Adjust(3)
  170.  
  171.   
  172.   
  173.   'Now check if any Adjust codes are zero
  174.   'If it is zero make it not zero (any number is fine!)
  175.   For Looper = 1 To 4
  176.     If Adjust(Looper) = 0 Then Adjust(Looper) = Looper + Len(PASSWORD$)
  177.   Next Looper
  178.  
  179.   
  180.   'Now check if any adjusts are the same
  181.   NotYet% = 1
  182.   Do While NotYet%
  183.     NotYet% = 0
  184.     For Loop1 = 1 To 4
  185.       For Loop2 = 1 To 4
  186.         'Don't compare same items
  187.         If Loop1 <> Loop2 Then
  188.           
  189.           'Check for a match
  190.           If Adjust(Loop1) = Adjust(Loop2) Then
  191.             Adjust(Loop2) = Adjust(Loop2) + Len(PASSWORD$)
  192.             
  193.             'Make sure we didn't make it zero
  194.             If Adjust(Loop2) = 0 Then Adjust(2) = Adjust(Loop2) + Len(PASSWORD$)
  195.             
  196.             NotYet% = 1
  197.           End If
  198.  
  199.         End If
  200.       Next Loop2
  201.     Next Loop1
  202.   Loop
  203.  
  204.  
  205.   
  206.   
  207.   'Encode or deocde
  208.   Counts = 0: Looper = 0
  209.  
  210.   'Loop until scanned though the whole file
  211.   Do While Looper < Len(strng$)
  212.     
  213.     'Add to Looper
  214.     Looper = Looper + 1
  215.  
  216.     'Keep Adjust code Counts from 1 to 4
  217.     Counts = Counts + 1
  218.     If Counts = 5 Then Counts = 1
  219.     
  220.     'Get the character to change
  221.     ToChange = Asc(Mid$(strng$, Looper, 1))
  222.     
  223.     'ENCODE   Flag%=0
  224.     If Flag% = 0 Then
  225.       
  226.       'If adjustment to high or low then reverse the coding and
  227.       'add in a chr$(255) to mark the change
  228.       If ToChange - Adjust(Counts) < 1 Or ToChange - Adjust(Counts) > 254 Then
  229.         
  230.         Addin$ = Chr$(255) + Chr$(ToChange + Adjust(Counts))
  231.         strng$ = Left$(strng$, Looper - 1) + Addin$ + Mid$(strng$, Looper + 1)
  232.         Looper = Looper + 1
  233.       
  234.       'If adjustment OK then just cahnge the character
  235.       Else
  236.         
  237.         Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  238.  
  239.       End If
  240.  
  241.     'DECODE  Flag% <> 0
  242.     Else
  243.       
  244.       'If find a CHR$(255) then remove it and set Flag255% to
  245.       'ensure reverse codes on next pass reverse coding
  246.       If ToChange = 255 Then
  247.         
  248.         strng$ = Left$(strng$, Looper - 1) + Mid$(strng$, Looper + 1)
  249.         Flag255% = 1
  250.         'Since CHR$(255) was removed we need to back up Looper
  251.         'and Counts because characters all shifted to the left
  252.         Looper = Looper - 1
  253.         Counts = Counts - 1
  254.       
  255.       'If not CHR$(255) then decode watching if Flag255% is set
  256.       Else
  257.         If Flag255% = 1 Then
  258.           Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  259.           Flag255% = 0
  260.         Else
  261.           Mid$(strng$, Looper, 1) = Chr$(ToChange + Adjust(Counts))
  262.         End If
  263.       End If
  264.  
  265.     End If
  266.     
  267.   Loop
  268.  
  269.   
  270.   
  271.   
  272.   'Set function equal to changed string
  273.   If Flag% = 0 Then
  274.     
  275.     'Tack on CHR$(255) to end so it can be recognized as encoded
  276.     KTEncrypt = strng$ + String$(5, 255)
  277.  
  278.   Else
  279.     
  280.     KTEncrypt = strng$
  281.   
  282.   End If
  283.  
  284.   'Make sure Errors$ is cleared
  285.   Error